home *** CD-ROM | disk | FTP | other *** search
Attribute VB_Name = "General" Option Explicit 'For Get and Write Var Declare Function writeprivateprofilestring Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyname As Any, ByVal lpString As String, ByVal lpfilename As String) As Long Declare Function getprivateprofilestring Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyname As Any, ByVal lpdefault As String, ByVal lpreturnedstring As String, ByVal nsize As Long, ByVal lpfilename As String) As Long 'For KeyInput Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer Sub RefreshMapList() '***************************************************************** 'Updates the maps list in the map list '***************************************************************** Dim LoopC As Integer Dim ActualNumMaps As Integer frmMain.MapLst.Clear 'Add maps to the map list For LoopC = 1 To NumMaps If FileExist(App.Path & MapPath & "Map" & LoopC & ".dat", vbNormal) = True Then frmMain.MapLst.AddItem "Map " & LoopC frmMain.MapLst.ItemData(frmMain.MapLst.ListCount - 1) = LoopC ActualNumMaps = LoopC End If Next LoopC NumMaps = ActualNumMaps End Sub Sub SwitchMap(Map As Integer) '***************************************************************** 'Loads and switches to a new room '***************************************************************** Dim LoopC As Integer Dim TempInt As Integer Dim Body As Integer Dim Head As Integer Dim Heading As Byte Dim Y As Integer Dim X As Integer 'Change mouse icon frmMain.MousePointer = 11 'Open files Open App.Path & MapPath & "Map" & Map & ".map" For Binary As #1 Seek #1, 1 Open App.Path & MapPath & "Map" & Map & ".inf" For Binary As #2 Seek #2, 1 'map Header Get #1, , MapInfo.MapVersion Get #1, , TempInt Get #1, , TempInt Get #1, , TempInt Get #1, , TempInt 'inf Header Get #2, , TempInt Get #2, , TempInt Get #2, , TempInt Get #2, , TempInt Get #2, , TempInt 'Load arrays For Y = YMinMapSize To YMaxMapSize For X = XMinMapSize To XMaxMapSize '.map file Get #1, , MapData(X, Y).Blocked For LoopC = 1 To 4 Get #1, , MapData(X, Y).Graphic(LoopC).GrhIndex 'Set up GRH If MapData(X, Y).Graphic(LoopC).GrhIndex > 0 Then InitGrh MapData(X, Y).Graphic(LoopC), MapData(X, Y).Graphic(LoopC).GrhIndex End If Next LoopC 'Empty place holders for future expansion Get #1, , TempInt Get #1, , TempInt '.inf file 'Tile exit Get #2, , MapData(X, Y).TileExit.Map Get #2, , MapData(X, Y).TileExit.X Get #2, , MapData(X, Y).TileExit.Y 'make NPC Get #2, , MapData(X, Y).NPCIndex If MapData(X, Y).NPCIndex > 0 Then Body = Val(GetVar(IniPath & "NPC.dat", "NPC" & MapData(X, Y).NPCIndex, "Body")) Head = Val(GetVar(IniPath & "NPC.dat", "NPC" & MapData(X, Y).NPCIndex, "Head")) Heading = Val(GetVar(IniPath & "NPC.dat", "NPC" & MapData(X, Y).NPCIndex, "Heading")) Call MakeChar(NextOpenChar(), Body, Head, Heading, X, Y) End If 'Make obj Get #2, , MapData(X, Y).OBJInfo.OBJIndex Get #2, , MapData(X, Y).OBJInfo.Amount If MapData(X, Y).OBJInfo.OBJIndex > 0 Then InitGrh MapData(X, Y).ObjGrh, Val(GetVar(IniPath & "OBJ.dat", "OBJ" & MapData(X, Y).OBJInfo.OBJIndex, "GrhIndex")) End If 'Empty place holders for future expansion Get #2, , TempInt Get #2, , TempInt Next X Next Y 'Close files Close #1 Close #2 'Other Room Data MapInfo.Name = GetVar(App.Path & MapPath & "Map" & Map & ".dat", "Map" & Map, "Name") frmMain.MapNameTxt = MapInfo.Name MapInfo.Music = GetVar(App.Path & MapPath & "Map" & Map & ".dat", "Map" & Map, "MusicNum") frmMain.MusNumTxt = MapInfo.Music MapInfo.StartPos.Map = Val(ReadField(1, GetVar(App.Path & MapPath & "Map" & Map & ".dat", "Map" & Map, "StartPos"), 45)) MapInfo.StartPos.X = Val(ReadField(2, GetVar(App.Path & MapPath & "Map" & Map & ".dat", "Map" & Map, "StartPos"), 45)) MapInfo.StartPos.Y = Val(ReadField(3, GetVar(App.Path & MapPath & "Map" & Map & ".dat", "Map" & Map, "StartPos"), 45)) frmMain.StartPosTxt = MapInfo.StartPos.Map & "-" & MapInfo.StartPos.X & "-" & MapInfo.StartPos.Y frmMain.MapVersionTxt = MapInfo.MapVersion CurMap = Map frmMain.MapNameTxt.Text = "Map " & CurMap 'Set changed flag MapInfo.Changed = 0 'Change mouse icon frmMain.MousePointer = 0 End Sub Sub CheckKeys() '***************************************************************** 'Checks keys '***************************************************************** 'Check arrow keys If UserMoving = 0 Then If GetKeyState(vbKeyUp) < 0 Then If WalkMode = True Then If LegalPos(UserPos.X, UserPos.Y - 1) Then MoveCharbyHead UserCharIndex, NORTH MoveScreen NORTH End If Else MoveScreen NORTH End If Exit Sub End If If GetKeyState(vbKeyRight) < 0 Then If WalkMode = True Then If LegalPos(UserPos.X + 1, UserPos.Y) Then MoveCharbyHead UserCharIndex, EAST MoveScreen EAST End If Else MoveScreen EAST End If Exit Sub End If If GetKeyState(vbKeyDown) < 0 Then If WalkMode = True Then If LegalPos(UserPos.X, UserPos.Y + 1) Then MoveCharbyHead UserCharIndex, SOUTH MoveScreen SOUTH End If Else MoveScreen SOUTH End If Exit Sub End If If GetKeyState(vbKeyLeft) < 0 Then If WalkMode = True Then If LegalPos(UserPos.X - 1, UserPos.Y) Then MoveCharbyHead UserCharIndex, WEST MoveScreen WEST End If Else MoveScreen WEST End If Exit Sub End If End If End Sub Sub ReacttoMouseClick(Button As Integer, tX As Integer, tY As Integer) '***************************************************************** 'React to mouse button '***************************************************************** Dim LoopC As Integer Dim NPCIndex As Integer Dim OBJIndex As Integer Dim Head As Integer Dim Body As Integer Dim Heading As Byte 'Right If Button = vbRightButton Then 'Show Info 'Position frmMain.StatTxt.Text = frmMain.StatTxt.Text & ENDL & "Position " & tX & "," & tY & " Blocked=" & MapData(tX, tY).Blocked 'Exits If MapData(tX, tY).TileExit.Map > 0 Then frmMain.StatTxt.Text = frmMain.StatTxt.Text & ENDL & "Tile Exit: " & MapData(tX, tY).TileExit.Map & "," & MapData(tX, tY).TileExit.X & "," & MapData(tX, tY).TileExit.Y End If 'NPCs If MapData(tX, tY).NPCIndex > 0 Then frmMain.StatTxt.Text = frmMain.StatTxt.Text & ENDL & "NPC: " & GetVar(IniPath & "NPC.dat", "NPC" & MapData(tX, tY).NPCIndex, "Name") End If 'OBJs If MapData(tX, tY).OBJInfo.OBJIndex > 0 Then frmMain.StatTxt.Text = frmMain.StatTxt.Text & ENDL & "OBJ: " & GetVar(IniPath & "OBJ.dat", "OBJ" & MapData(tX, tY).OBJInfo.OBJIndex, "Name") & " Amount=" & MapData(tX, tY).OBJInfo.Amount End If 'Append frmMain.StatTxt.Text = frmMain.StatTxt.Text & ENDL frmMain.StatTxt.SelStart = Len(frmMain.StatTxt.Text) Exit Sub End If 'Left click If Button = vbLeftButton Then '************** Place grh If frmMain.PlaceGrhCmd.Enabled = False Then 'Erase 2-4 If frmMain.EraseAllchk.value = 1 Then For LoopC = 2 To 4 MapData(tX, tY).Graphic(LoopC).GrhIndex = 0 Next LoopC Exit Sub End If 'Erase layer If frmMain.Erasechk.value = 1 Then If Val(frmMain.Layertxt.Text) = 1 Then MsgBox "Can't Erase Layer 1" Exit Sub End If MapData(tX, tY).Graphic(Val(frmMain.Layertxt.Text)).GrhIndex = 0 Exit Sub End If 'Else Place graphic MapData(tX, tY).Blocked = frmMain.Blockedchk.value MapData(tX, tY).Graphic(Val(frmMain.Layertxt.Text)).GrhIndex = Val(frmMain.Grhtxt.Text) 'Setup GRH InitGrh MapData(tX, tY).Graphic(Val(frmMain.Layertxt.Text)), Val(frmMain.Grhtxt.Text) End If '************** Place blocked tile If frmMain.PlaceBlockCmd.Enabled = False Then MapData(tX, tY).Blocked = frmMain.Blockedchk.value End If '************** Place exit If frmMain.PlaceExitCmd.Enabled = False Then If frmMain.EraseExitChk.value = 0 Then MapData(tX, tY).TileExit.Map = Val(frmMain.MapExitTxt.Text) MapData(tX, tY).TileExit.X = Val(frmMain.XExitTxt.Text) MapData(tX, tY).TileExit.Y = Val(frmMain.YExitTxt.Text) Else MapData(tX, tY).TileExit.Map = 0 MapData(tX, tY).TileExit.X = 0 MapData(tX, tY).TileExit.Y = 0 End If End If '************** Place NPC If frmMain.PlaceNPCCmd.Enabled = False Then If frmMain.EraseNPCChk.value = 0 Then If frmMain.NPCLst.ListIndex >= 0 Then NPCIndex = frmMain.NPCLst.ListIndex + 1 Body = Val(GetVar(IniPath & "NPC.dat", "NPC" & NPCIndex, "Body")) Head = Val(GetVar(IniPath & "NPC.dat", "NPC" & NPCIndex, "Head")) Heading = Val(GetVar(IniPath & "NPC.dat", "NPC" & NPCIndex, "Heading")) Call MakeChar(NextOpenChar(), Body, Head, Heading, tX, tY) MapData(tX, tY).NPCIndex = NPCIndex End If Else If MapData(tX, tY).NPCIndex > 0 Then MapData(tX, tY).NPCIndex = 0 Call EraseChar(MapData(tX, tY).CharIndex) End If End If End If '************** Place OBJ If frmMain.PlaceObjCmd.Enabled = False Then If frmMain.EraseObjChk.value = 0 Then If frmMain.ObjLst.ListIndex >= 0 Then OBJIndex = frmMain.ObjLst.ListIndex + 1 InitGrh MapData(tX, tY).ObjGrh, Val(GetVar(IniPath & "OBJ.dat", "OBJ" & OBJIndex, "GrhIndex")) MapData(tX, tY).OBJInfo.OBJIndex = OBJIndex MapData(tX, tY).OBJInfo.Amount = Val(frmMain.OBJAmountTxt) End If Else MapData(tX, tY).OBJInfo.OBJIndex = 0 MapData(tX, tY).OBJInfo.Amount = 0 MapData(tX, tY).ObjGrh.GrhIndex = 0 End If End If 'Set changed flag MapInfo.Changed = 1 End If End Sub Function FileExist(File As String, FileType As VbFileAttribute) As Boolean '***************************************************************** 'Checks to see if a file exists '***************************************************************** If Dir(File, FileType) = "" Then FileExist = False Else FileExist = True End If End Function Public Function ReadField(Pos As Integer, Text As String, SepASCII As Integer) As String '***************************************************************** 'Gets a field from a string '***************************************************************** Dim i As Integer Dim LastPos As Integer Dim CurChar As String * 1 Dim FieldNum As Integer Dim Seperator As String Seperator = Chr(SepASCII) LastPos = 0 FieldNum = 0 For i = 1 To Len(Text) CurChar = Mid(Text, i, 1) If CurChar = Seperator Then FieldNum = FieldNum + 1 If FieldNum = Pos Then ReadField**** Place OBJ If F + 1 If FieldNum = Pos Then ReadField*e 
